home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / symbolicdiff.lsp < prev    next >
Lisp/Scheme  |  1990-10-11  |  3KB  |  85 lines
  1. ; book pp.110-117
  2.  
  3. (defun deriv (exp var)
  4.   (cond
  5.     ((constantp exp) 0)
  6.     ((variablep exp) (if (same-variable-p exp var) 1 0))
  7.     ((sump exp)
  8.      (make-sum (deriv (addend exp) var)
  9.                (deriv (augend exp)var)))
  10.     ((productp exp)
  11.      (make-sum (make-product (multiplier exp)
  12.                              (deriv (multiplicand exp) var))
  13.                (make-product (deriv (multiplier exp) var)
  14.                              (multiplicand exp))))
  15.     ((unary-p exp)
  16.      (make-product (make-unary-deriv (unary-function exp)
  17.                                      (unary-argument exp))
  18.                    (deriv (unary-argument exp) var)))
  19.     (t (error "Can't differentiate this expression"))))
  20.  
  21. (defun addend (e) (second e))
  22. (defun augend (e) (third e))
  23. (defun make-sum (a1 a2) 
  24.   (cond
  25.     ((and (numberp a1) (numberp a2)) (+ a1 a2))
  26.     ((numberp a1) (if (= a1 0) a2 (list '+ a1 a2)))
  27.     ((numberp a2) (if (= a2 0) a1 (list '+ a1 a2)))
  28.     (t (list '+ a1 a2))))
  29.  
  30. (defun multiplier (e) (second e))
  31. (defun multiplicand (e) (third e))
  32. (defun make-product (m1 m2)
  33.   (cond
  34.     ((and (numberp m1) (numberp m2)) (* m1 m2))
  35.     ((numberp m1)
  36.      (cond ((= m1 0) 0)
  37.            ((= m1 1) m2)
  38.            (t (list '* m1 m2))))
  39.     ((numberp m2)
  40.      (cond ((= m2 0) 0)
  41.            ((= m2 1) m1)
  42.            (t (list '* m1 m2))))
  43.     (t (list '* m1 m2))))
  44.  
  45. (defun constantp (e) (numberp e))
  46. (defun variablep (e) (symbolp e))
  47. (defun same-variable-p (v1 v2)
  48.   (and (variablep v1) (variablep v2) (eq v1 v2)))
  49. (defun sump (e)
  50.   (and (listp e) (= (length e) 3) (eq (first e) '+)))
  51. (defun productp (e)
  52.   (and (listp e) (= (length e) 3) (eq (first e) '*)))
  53. #|
  54. (defun make-unary-deriv (fcn arg)
  55.   (case fcn
  56.     (exp (make-unary 'exp arg))
  57.     (sin (make-unary 'cos arg))
  58.     (cos (make-product -1 (make-uanry 'sin arg)))
  59.     (t (error "Can't differentiate this expression"))))
  60. |#
  61. (defun make-unary-deriv (fcn arg)
  62.   (apply-unary-rule (get-unary-rule fcn) arg))
  63. (defun unary-p (e)
  64.   (and (listp e) (= (length e) 2)))
  65. (defun unary-function (e) (first e))
  66. (defun unary-argument (e) (second e))
  67. (defun make-unary (fcn arg) (list fcn arg))
  68.  
  69. (def *derivatives* nil)
  70. (defun add-unary-rule (f rule)
  71.   (setf *derivatives* (cons (list f rule) *derivatives*)))
  72. (defun get-unary-rule (f)
  73.   (let ((rule (assoc f *derivatives*)))
  74.    (if rule
  75.        rule
  76.        (error "Can't differentiate this expression"))))
  77. (defun apply-unary-rule (entry arg)
  78.   (funcall (second entry) arg))
  79.  
  80. (add-unary-rule 'exp #'(lambda (x) (make-unary 'exp x)))
  81. (add-unary-rule 'sin #'(lambda (x) (make-unary 'cos x)))
  82. (add-unary-rule 'cos
  83.                 #'(lambda (x)
  84.                   (make-product -1 (make-unary 'sin x))))
  85.